home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / comp-method.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  10.7 KB  |  319 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: comp-method.scm,v 1.12 1992/09/11 02:10:54 jmiller Exp $
  39.  
  40. ;;;; More of the compiler: METHOD and DEFINE-METHOD
  41.  
  42. ;;; Parsing and compiling of METHOD form
  43.  
  44. (define (validate-names names)
  45.   (define (validate name)
  46.     (if (not (variable-name? name))
  47.     (dylan::error "invalid parameter name" name names)))
  48.   (for-each validate names)
  49.   (must-be-unique names memq "parameter names not unique"))
  50.  
  51. (define (parse-requireds orig-l continuation)
  52.   (define (oops l) (cant-parse "requireds" orig-l l))
  53.   (let loop ((l orig-l)
  54.          (requireds '()))
  55.     (cond ((null? l) (continuation (reverse requireds) l))
  56.       ((pair? l)
  57.        (let ((this-param (car l)))
  58.          (cond ((or (eq? this-param '!next)
  59.             (eq? this-param '!rest)
  60.             (eq? this-param '!key))
  61.             (continuation (reverse requireds) l))
  62.            ((variable-name? this-param)
  63.             (loop (cdr l)
  64.               `((,this-param <object>)
  65.                 ,@requireds)))
  66.            ((and (pair? this-param)
  67.              (variable-name? (car this-param))
  68.              (pair? (cdr this-param))
  69.              (null? (cdr (cdr this-param))))
  70.             (loop (cdr l)
  71.               `((,(car this-param)
  72.                  ,(cadr this-param))
  73.                 ,@requireds)))
  74.            (else (oops l)))))
  75.       (else (oops l)))))
  76.  
  77. (define (make-parse-next/rest flag name)
  78.   (lambda (orig-l continuation)
  79.     (cond ((null? orig-l) (continuation #F orig-l))
  80.       ((pair? orig-l)
  81.        (let ((this-param (car orig-l))
  82.          (next-params (cdr orig-l)))
  83.          (if (and (eq? this-param flag)
  84.               (pair? next-params)
  85.               (variable-name? (car next-params)))
  86.          (continuation (car next-params) (cdr next-params))
  87.          (continuation #F orig-l))))
  88.       (else (cant-parse name orig-l orig-l)))))
  89.  
  90. (define parse-next (make-parse-next/rest '!next "next"))
  91. (define parse-rest (make-parse-next/rest '!rest "rest"))
  92.  
  93. (define (parse-keys orig-l continuation)
  94.   (define (oops l) (cant-parse "keys" orig-l l))
  95.   (define (loop l keys)
  96.     (cond
  97.      ((null? l) (continuation (if (null? keys) #T (reverse keys))))
  98.      ((pair? l)
  99.       (let ((this-param (car l)))
  100.     (cond
  101.      ((symbol? this-param)
  102.       (loop (cdr l)
  103.         `((,(name->keyword this-param) ,this-param #F)
  104.           ,@keys)))
  105.      ((pair? this-param)
  106.       (cond
  107.        ((keyword? (car this-param))
  108.         (let ((the-key (car this-param))
  109.           (the-rest (cdr this-param)))
  110.           (if (and (pair? the-rest)
  111.                (symbol? (car the-rest)))
  112.           (let ((variable (car the-rest))
  113.             (the-rest (cdr the-rest)))
  114.             (cond
  115.              ((null? the-rest)
  116.               (loop (cdr l)
  117.                 `((,the-key ,variable #F)
  118.                   ,@keys)))
  119.              ((and (pair? the-rest)
  120.                (null? (cdr the-rest)))
  121.               (loop (cdr l)
  122.                 `((,the-key ,variable ,(car the-rest))
  123.                   ,@keys)))
  124.              (else (oops l))))
  125.           (oops l))))
  126.        ((symbol? (car this-param))
  127.         (let ((variable (car this-param))
  128.           (the-rest (cdr this-param)))
  129.           (cond
  130.            ((null? the-rest)
  131.         (loop (cdr l)
  132.               `((,(name->keyword variable) ,variable #F)
  133.             ,@keys)))
  134.            ((pair? the-rest)
  135.         (let ((expr (car the-rest))
  136.               (the-rest (cdr the-rest)))
  137.           (if (null? the-rest)
  138.               (loop
  139.                (cdr l)
  140.                `((,(name->keyword variable) ,variable ,expr)
  141.              ,@keys))
  142.               (oops l))))
  143.            (else (oops l)))))
  144.        (else (oops l))))
  145.      (else (oops l)))))
  146.      (else (oops l))))
  147.   (cond ((null? orig-l) (continuation #F))
  148.     ((and (pair? orig-l)
  149.           (eq? (car orig-l) '!key))
  150.      (loop (cdr orig-l) '()))
  151.     (else (oops orig-l))))
  152.  
  153. (define (parse-METHOD-parameter-list orig-list default-next-method continue)
  154.   (parse-requireds orig-list
  155.     (lambda (required-params l)
  156.       (parse-next l
  157.         (lambda (next l)
  158.       (parse-rest l
  159.         (lambda (rest-param l)
  160.           (parse-keys l
  161.             (lambda (keys)
  162.           (validate-names
  163.            (append (map car required-params)
  164.                (if next (list next) '())
  165.                (if rest-param (list rest-param) '())
  166.                (if (pair? keys) (map cadr keys) '())))
  167.           (if (pair? keys)
  168.               (must-be-unique (map car keys) memq
  169.                       "keywords not unique"))
  170.           (continue required-params
  171.                 (or next default-next-method)
  172.                 rest-param
  173.                 keys))))))))))
  174.  
  175. (define (compile-METHOD-form
  176.      e mod-vars bound-vars compiler multiple-values? continue)
  177.   multiple-values?            ; No reductions
  178.   (must-be-list-of-at-least-length e 2 "METHOD -- invalid syntax")
  179.   (let ((params (car e))
  180.     (forms (cdr e)))
  181.     (parse-METHOD-parameter-list params '!NEXT-METHOD
  182.       (lambda (reqs next rest keys)
  183.     (define (lambda-list req-names)
  184.       `(!MULTI-VALUES ,next ,@req-names .
  185.           ,(cond (rest rest) (keys '!keys) (else '()))))
  186.     (let ((req-names (map car reqs))
  187.           (req-restrictions (map cadr reqs))
  188.           (key-name (if rest rest '!keys)))
  189.       (compile-forms req-restrictions mod-vars bound-vars compiler #F
  190.         (lambda (restrictions mod-vars)
  191.           (define (generate mod-vars validation-code)
  192.         (continue
  193.          `(DYLAN::MAKE-METHOD
  194.            (DYLAN::MAKE-PARAM-LIST
  195.             (DYLAN::LIST
  196.              ,@(map (lambda (name code)
  197.                   `(DYLAN::LIST ',name ,code))
  198.                 req-names restrictions))
  199.             ',next ',rest ',(if (pair? keys) (map car keys) keys))
  200.            (LAMBDA ,(lambda-list req-names) ,@validation-code))
  201.          mod-vars))
  202.           (compile-forms
  203.            forms mod-vars
  204.            (append (list next) req-names (if rest (list rest) '())
  205.                (if (pair? keys) (map cadr keys) '()) bound-vars)
  206.            compiler '!MULTI-VALUES
  207.            (lambda (body-forms mod-vars)
  208.          (cond
  209.           ((not keys) (generate mod-vars body-forms))
  210.           ((eq? keys #T)
  211.            (generate mod-vars
  212.                  `((DYLAN::KEYWORD-VALIDATE ,next ,key-name #T)
  213.                    ,@body-forms)))
  214.           (else
  215.            (compile-let*-forms
  216.             (map cadr keys) (map caddr keys) mod-vars
  217.             (append (list next) req-names
  218.                 (if rest (list rest) '()) bound-vars)
  219.             compiler #F
  220.             (lambda (defaults mod-vars)
  221.               (generate
  222.                mod-vars
  223.                `((DYLAN::KEYWORD-VALIDATE
  224.               ,next ,key-name
  225.               ,(if rest #T `',(map car keys)))
  226.              (LET* (,@(map
  227.                    (lambda (key var default)
  228.                      `(,key
  229.                        (DYLAN::FIND-KEYWORD
  230.                     ,key-name ',var
  231.                     (LAMBDA () ,default))))
  232.                        (map cadr keys)
  233.                        (map car keys)
  234.                        defaults))
  235.                ,@body-forms))))))))))))))))
  236.  
  237. (define (compile-let*-forms
  238.      names forms module-vars bound-vars
  239.      compiler multiple-values? continue)
  240.   (let loop ((result '())
  241.          (forms forms)
  242.          (names names)
  243.          (bound-vars bound-vars)
  244.          (mod-vars module-vars))
  245.     (if (null? forms)
  246.     (continue (reverse result) mod-vars)
  247.     (compiler (car forms) mod-vars bound-vars multiple-values?
  248.       (lambda (compiled mod-vars)
  249.         (loop (cons compiled result) (cdr forms) (cdr names)
  250.           (cons (car names) bound-vars) mod-vars))))))
  251.  
  252. (define (compile-DEFINE-METHOD-form
  253.      e mod-vars bound-vars compiler multiple-values? continue)
  254.   (define (rebuild-param-list params)
  255.     (let loop ((result '())
  256.            (so-far params))
  257.       (if (null? so-far)
  258.       (reverse `(NEXT-METHOD !NEXT ,@result))
  259.       (case (car so-far)
  260.         ((!next) params)
  261.         ((!rest !key) `(,@(reverse result) !NEXT NEXT-METHOD ,@so-far))
  262.         (else (loop (cons (car so-far) result)
  263.             (cdr so-far)))))))
  264.       
  265.   multiple-values?            ; Doesn't reduce
  266.   (must-be-list-of-at-least-length e 3
  267.    "DEFINE-METHOD -- invalid syntax")
  268.   (let ((name (car e))
  269.     (params (cadr e))
  270.     (forms (cddr e)))
  271.     (if (not (variable-name? name))
  272.     (dylan::error "DEFINE-METHOD -- illegal name" name params forms))
  273.     (compiler `(METHOD ,(rebuild-param-list params) ,@forms)
  274.           mod-vars bound-vars #F
  275.       (lambda (method-code mod-vars)
  276.     (module-refs
  277.      name bound-vars mod-vars
  278.      continue
  279.      (lambda (ref set)
  280.        (parse-METHOD-parameter-list params #F
  281.          (lambda (reqs next rest keys)
  282.            `(BEGIN
  283.           (COND ((DYLAN::EQ? ,ref ',the-unassigned-value)
  284.              ,(set `(DYLAN::CREATE-GENERIC-FUNCTION
  285.                  ',(variable->name name)
  286.                  ,(length reqs)
  287.                  #F    ; No required keywords
  288.                  ,(if (or keys rest) #T #F))))
  289.             ((DYLAN::NOT (DYLAN::GENERIC-FUNCTION? ,ref))
  290.              (DYLAN-CALL DYLAN:ERROR
  291.                      "DEFINE-METHOD -- already has a value"
  292.                      ',name ,ref ',reqs ',next ',rest ',keys)))
  293.           (DYLAN::ADD-METHOD ,ref ,method-code)
  294.           ',name)))))))))
  295.  
  296. (define (compile-BIND-METHODS-form
  297.      e mod-vars bound-vars compiler multiple-values? continue)
  298.   (must-be-list-of-at-least-length e 2 "BIND-METHODS -- bad syntax")
  299.   (let ((bindings (car e))
  300.     (forms (cdr e)))
  301.     (for-each (lambda (binding)
  302.         (must-be-list-of-at-least-length binding 3
  303.           "BIND-METHODS -- illegal binding syntax"))
  304.           bindings)
  305.     (let ((names (map car bindings))
  306.       (methods (map (lambda (binding)
  307.               `(METHOD ,(cadr binding)
  308.                    ,@(cddr binding)))
  309.             bindings)))
  310.       (let ((new-bvs (append names bound-vars)))
  311.     (compile-forms methods mod-vars new-bvs compiler #F
  312.       (lambda (method-bodies mod-vars)
  313.         (compile-forms forms mod-vars new-bvs compiler multiple-values?
  314.           (lambda (body-codes mod-vars)
  315.         (continue
  316.          `(LETREC (,@(map list names method-bodies))
  317.             ,@body-codes)
  318.          mod-vars)))))))))
  319.